home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / you-075a.lha / you-075a / root.c < prev    next >
C/C++ Source or Header  |  1992-06-18  |  13KB  |  516 lines
  1. /* ******************************************************************** */
  2. /*  root.c           Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* The root level operations                                        */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * Change Log:
  9.  *   Version 1, March 1990 (Compiler rationalisation)
  10.  */
  11.  
  12. #include <stdio.h>
  13. #include <string.h>
  14.  
  15. #include "funcalls.h"
  16. #include "defs.h"
  17. #include "structs.h"
  18.  
  19. #include "error.h"
  20. #include "global.h"
  21. #include "slots.h"
  22. #include "table.h"
  23. #include "garbage.h"
  24.  
  25. #include "allocate.h"
  26. #include "modboot.h"
  27. #include "symboot.h"
  28. #include "modules.h"
  29. #include "toplevel.h"
  30. #include "root.h"
  31. #include "copy.h"
  32.  
  33. #define ROOT_ENTRIES 11
  34. MODULE Module_root;
  35. LispObject Module_root_values[ROOT_ENTRIES];
  36.  
  37. static SYSTEM_GLOBAL(LispObject,list_search_path);
  38. static SYSTEM_GLOBAL(int,load_verbosity);
  39.  
  40. static LispObject sym_eval_cm,sym_set_cm;
  41.  
  42. EUFUN_2( eval_cm_template, env, form)
  43. {
  44.   return(EUCALL_3(module_eval,env->ENV.value,NULL,form));
  45. }
  46. EUFUN_CLOSE
  47.  
  48. EUFUN_3( set_cm_template, env, sym, val)
  49. {
  50.   if (!is_symbol(sym))
  51.     CallError(stacktop,"set/cm: not a symbol",sym,NONCONTINUABLE);
  52.   printf("No set/cm yet...\n");
  53.   (void) EUCALL_3(module_set,((Env)env)->value,sym,val);
  54.  
  55.   return(val);
  56. }
  57. EUFUN_CLOSE
  58.  
  59. void make_default_module_functions(LispObject *stacktop,LispObject mod)
  60. {
  61.   LispObject f;
  62.  
  63.   STACK_TMP(mod);
  64.   f = make_anonymous_module_env_function_1(stacktop,mod,eval_cm_template,1,
  65.                        sym_nil,mod);
  66.   UNSTACK_TMP(mod);
  67.   STACK_TMP(mod);
  68.   (void) module_set_new(stacktop,mod,sym_eval_cm,f);        
  69.   UNSTACK_TMP(mod);
  70.   STACK_TMP(mod);
  71.   f = make_anonymous_module_env_function_1(stacktop,mod,set_cm_template,2,
  72.                        sym_nil,mod);
  73.   UNSTACK_TMP(mod);
  74.   (void) module_set_new(stacktop,mod,sym_set_cm,f);
  75.  
  76. }
  77.  
  78. EUFUN_3( Rf_defmodule, mod, env, forms)
  79. {
  80.   LispObject name,import_specs,syntax_specs;
  81.   LispObject module;
  82.   LispObject walker;
  83.  
  84.   if (!is_cons(forms))
  85.     CallError(stacktop,"defmodule: missing name",nil,NONCONTINUABLE);
  86.  
  87.   name = CAR(forms); forms = CDR(forms);
  88.  
  89.   if (!is_symbol(name))
  90.     CallError(stacktop,"defmodule: non-symbolic name",name,NONCONTINUABLE);
  91.  
  92.   /* Overwrite existing one... */ /* HACK !!! */
  93.  
  94.   if (!is_cons(forms))
  95.     CallError(stacktop,"defmodule: missing import specs",nil,NONCONTINUABLE);
  96.  
  97.   import_specs = CAR(forms); forms = CDR(forms);
  98.  
  99.   if (!is_cons(import_specs) && import_specs != nil)
  100.     CallError(stacktop,
  101.           "defmodule: bad import spec",import_specs,NONCONTINUABLE);
  102.  
  103.   if (!is_cons(forms))
  104.     CallError(stacktop,"defmodule: missing syntax spec",nil,NONCONTINUABLE);
  105.  
  106.   syntax_specs = CAR(forms); forms = CDR(forms);
  107.   
  108.   if (syntax_specs != nil)
  109.     CallError(stacktop,
  110.           "defmodule: non-null syntax spec",syntax_specs,NONCONTINUABLE);
  111.  
  112.   /* Should do the loading here maybe... */ /* HACK !!! */
  113.   STACK_TMP(name);
  114.   module = allocate_i_module(stacktop,name);
  115.  
  116.   /* Insert eval/cm and set/cm... */
  117.   STACK_TMP(module);
  118.   make_default_module_functions(stacktop,module);
  119.   UNSTACK_TMP(module);
  120.   /* recover import spec, etc */
  121.   forms =ARG_2(stackbase);
  122.   forms=CDR(forms);
  123.   import_specs = CAR(forms); forms = CDR(forms);
  124.   syntax_specs = CAR(forms); forms = CDR(forms);
  125.   ARG_2(stackbase)=forms;
  126.   STACK_TMP(module);
  127.  
  128.   process_import_spec(stacktop,module,import_specs);
  129.   
  130.   walker = ARG_2(stackbase)/*forms*/;
  131.   UNSTACK_TMP(module);
  132.   while (walker != nil) {
  133.     if (SYSTEM_GLOBAL_VALUE(load_verbosity) > 0) {
  134.       fprintf(StdOut->STREAM.handle,"Processing: ");
  135.       EUCALL_2(Fn_print, CAR(walker),StdOut);
  136.     }
  137.     STACK_TMP(CDR(walker));
  138.     STACK_TMP(module);    
  139.     EUCALL_2(process_top_level_form,module,CAR(walker));
  140.     UNSTACK_TMP(module);
  141.     UNSTACK_TMP(walker);
  142.   }
  143.   UNSTACK_TMP(name);
  144.   STACK_TMP(module);
  145.   put_module(stacktop,name,module);
  146.   UNSTACK_TMP(module);
  147.   return(module);
  148. }
  149. EUFUN_CLOSE
  150.  
  151. EUFUN_3( Rf_loaded_modules, mod, env, val)
  152. {
  153.   IGNORE(mod); IGNORE(env); IGNORE(val);
  154.  
  155.   return(EUCALL_1(Fn_table_keys, global_module_table));
  156. }
  157. EUFUN_CLOSE
  158.  
  159. extern LispObject Fn_close(LispObject*);
  160.  
  161. EUFUN_3( Rf_load_module, mod, env, form)
  162. {
  163.   IGNORE(mod); IGNORE(env);
  164.  
  165.   if (!is_cons(form))
  166.     CallError(stacktop,"load-module: invalid arguments",form,NONCONTINUABLE);
  167.   RESET_GLOBAL_STACK();
  168.   return(EUCALL_1(load_module,CAR(form)));
  169. }
  170. EUFUN_CLOSE
  171.  
  172. EUFUN_3( Rf_reload_module, mod, env, form)
  173. {
  174.   IGNORE(mod); IGNORE(env);
  175.  
  176.   if (!is_cons(form))
  177.     CallError(stacktop,"reload-module: invalid arguments",form,NONCONTINUABLE);
  178.  
  179.   /* Hack out original... */
  180.  
  181.   EUCALL_3(tref_updator, global_module_table,CAR(form),nil);
  182.   return(EUCALL_1(load_module,CAR(ARG_2(stackbase))));
  183. }
  184. EUFUN_CLOSE
  185.  
  186. static LispObject open_module_file(LispObject *stacktop,LispObject name)
  187. {
  188.   char path[200];
  189.   LispObject walker;
  190.   FILE *fd;
  191.  
  192.   if (!is_symbol(name))
  193.     CallError(stacktop,
  194.           "open-module-file: not a symbolic name",name,NONCONTINUABLE);
  195.  
  196.   walker = SYSTEM_GLOBAL_VALUE(list_search_path);
  197.   while (is_cons(walker)) {
  198.     LispObject dir;
  199.  
  200.     if (!is_string((dir = CAR(walker))))
  201.       CallError(stacktop,
  202.         "open-module-file: bad search directory",dir,NONCONTINUABLE);
  203.  
  204.     (void) strcpy(path,stringof(dir));
  205.     (void) strcat(path,"/");
  206.     (void) strcat(path,stringof(name->SYMBOL.pname));
  207.     (void) strcat(path,".em\0");
  208.  
  209.     if ((fd = fopen(path,"r")) == NULL)
  210.       walker = CDR(walker);
  211.     else
  212.       return((LispObject) allocate_stream(stacktop,fd,'r'));
  213.   }
  214.  
  215.   CallError(stacktop,"open-module-file: unable to find .em file for module",
  216.         name,NONCONTINUABLE);
  217.  
  218.   return(nil);
  219. }
  220.   
  221. EUFUN_1( load_module, name)
  222. {
  223.   char fname[100];
  224.   LispObject stream,form,ans;
  225.  
  226.   if (!is_symbol(name)) 
  227.     CallError(stacktop,
  228.           "load-module: non-symbolic module name",name,NONCONTINUABLE);
  229.  
  230.   /* Look if it's already loaded */
  231.  
  232.   if (module_loaded_p(stacktop,name)) return(get_module(stacktop,name));
  233.  
  234.   stream = open_module_file(stacktop,name);
  235.   
  236.   name=ARG_0(stackbase);
  237.   fprintf(StdOut->STREAM.handle,"Loading module '%s'\n",stringof(name->SYMBOL.pname));
  238.  
  239.   EUCALLSET_1(form, Fn_read, stream);
  240.  
  241. #if 0
  242.   EUCALL_2(Fn_print,form,StdErr); fflush(stderr);
  243. #endif
  244.  
  245.   EUCALL_1(Fn_close, stream);
  246.  
  247.   if (!is_cons(form))
  248.     CallError(stacktop,
  249.           "load module: invalid module definition",nil,NONCONTINUABLE);
  250.  
  251.   if (CAR(form) != sym_defmodule) 
  252.     CallError(stacktop,
  253.           "load module: invalid module definition",nil,NONCONTINUABLE);
  254.  
  255.   if(!is_cons(CDR(form)))
  256.     CallError(stacktop,
  257.           "load module: invalid definintion",form,NONCONTINUABLE);
  258.  
  259.   name=ARG_0(stackbase);
  260.   if (CAR(CDR(form)) != name)
  261.     CallError(stacktop,
  262.           "load module: module badly named",CAR(CDR(form)),NONCONTINUABLE);
  263.  
  264.   EUCALLSET_3(ans,Rf_defmodule,NULL,NULL,CDR(form));
  265.   
  266.   name=ARG_0(stackbase);
  267.   fprintf(StdOut->STREAM.handle,"Loaded '%s'\n",stringof(name->SYMBOL.pname));
  268.  
  269.   return(ans);
  270. }
  271. EUFUN_CLOSE
  272.  
  273. LispObject load_expanded_module(LispObject *stacktop,LispObject name)
  274. {
  275.   char fname[100];
  276.   LispObject stream,form;
  277.  
  278.   if (!is_symbol(name)) 
  279.     CallError(stacktop,
  280.           "load-expanded-module: non-symbolic module name",name,NONCONTINUABLE);
  281.  
  282.   /* Look if it's already loaded */
  283.  
  284.   if (module_loaded_p(stacktop,name)) return(get_module(stacktop,name));
  285.  
  286.   stream = open_module_file(stacktop,name);
  287. /*
  288.   fprintf(stderr,"Starting read..."); fflush(stderr);
  289. */
  290.  
  291.   fprintf(StdOut->STREAM.handle,"Loading module '%s'\n",stringof(name->SYMBOL.pname));
  292.  
  293.   STACK_TMP(form);
  294.   OFF_collect();
  295.   EUCALLSET_1(form, Fn_read, stream);
  296.   ON_collect();
  297.   UNSTACK_TMP(form);
  298. /*
  299.   fprintf(stderr,"Read complete.\n"); fflush(stderr);
  300. */
  301. #if 0
  302.   EUCALL_2(Fn_print, form,StdErr); fflush(stderr);
  303. #endif
  304.  
  305.   STACK_TMP(form);
  306.   EUCALL_1(Fn_close, stream);
  307.   UNSTACK_TMP(form);
  308.  
  309.   if (!is_cons(form))
  310.     CallError(stacktop,
  311.           "load module: invalid module definition",nil,NONCONTINUABLE);
  312.  
  313.   if (CAR(form) != sym_defmodule) 
  314.     CallError(stacktop,
  315.           "load module: invalid module definition",nil,NONCONTINUABLE);
  316.  
  317.   if(!is_cons(CDR(form)))
  318.     CallError(stacktop,
  319.           "load module: invalid definintion",form,NONCONTINUABLE);
  320.  
  321.   if (CAR(CDR(form)) != name)
  322.     CallError(stacktop,
  323.           "load module: module badly named",CAR(CDR(form)),NONCONTINUABLE);
  324.  
  325.   return EUCALL_3(Rf_defmodule,NULL,NULL,CDR(form));
  326. }
  327.  
  328. EUFUN_3( Rf_load_expanded_module, mod, env, forms)
  329. {
  330.   if (!is_cons(forms))
  331.     CallError(stacktop,
  332.           "load-expanded-module: invalid arguments",forms,NONCONTINUABLE);
  333.  
  334.   return(load_expanded_module(stacktop,CAR(forms)));
  335. }
  336. EUFUN_CLOSE
  337.  
  338. EUFUN_3( Rf_start_module, m, env, forms)
  339. {
  340.   LispObject modname,fname;
  341.   LispObject mod;
  342.  
  343.   if (!is_cons(forms))
  344.     CallError(stacktop,"start-module: invalid arguments",forms,NONCONTINUABLE);
  345.  
  346.   modname = CAR(forms); forms = CDR(forms);
  347.  
  348.   if (!is_symbol(modname))
  349.     CallError(stacktop,
  350.           "start-module: non-symbolic module name",modname,NONCONTINUABLE);
  351.  
  352.   if (!is_cons(forms))
  353.     CallError(stacktop,
  354.           "start-module: missing function name",forms,NONCONTINUABLE);
  355.  
  356.   fname = CAR(forms);
  357.  
  358.   if (!is_symbol(fname))
  359.     CallError(stacktop,
  360.           "start-module: non-symbolic function name",fname,NONCONTINUABLE);
  361.  
  362.   /* forms are hopefully (fname arg1 arg2 ...) */
  363.  
  364.   /* semantically dubious but... */
  365.  
  366.   mod = get_module(stacktop,modname);
  367.  
  368.   if (mod == nil)
  369.     CallError(stacktop,
  370.           "start-module: module not loaded",modname,NONCONTINUABLE);
  371.  
  372.   return(EUCALL_3(module_eval,mod,NULL,forms));
  373. }
  374. EUFUN_CLOSE
  375.  
  376. EUFUN_3( Rf_enter_module, m, env, form)
  377. {
  378.   LispObject name;
  379.   LispObject mod;
  380.  
  381.   if (!is_cons(form))
  382.     CallError(stacktop,"enter-module: invalid arguments",form,NONCONTINUABLE);
  383.  
  384.   name = CAR(form);
  385.   if (!is_symbol(name))
  386.     CallError(stacktop,
  387.           "enter-module: non-symbolic module name",name,NONCONTINUABLE);
  388.  
  389.   else {
  390.     mod = get_module(stacktop,name);
  391.     STACK_TMP(name);
  392.     if (mod == nil)
  393.       SYSTEM_GLOBAL_VALUE(current_interactive_module) =
  394.     EUCALL_1(load_module,name);
  395.     else
  396.       SYSTEM_GLOBAL_VALUE(current_interactive_module) = mod;
  397.     UNSTACK_TMP(name);
  398.   }
  399.  
  400.   return(name);
  401. }
  402. EUFUN_CLOSE
  403.  
  404. EUFUN_0( Rf_load_quietly)
  405. {
  406.   SYSTEM_GLOBAL_VALUE(load_verbosity) = 0;
  407.   return(nil);
  408. }
  409. EUFUN_CLOSE
  410.  
  411. EUFUN_0( Rf_load_loudly)
  412. {
  413.   SYSTEM_GLOBAL_VALUE(load_verbosity) = 1;
  414.   return(nil);
  415. }
  416. EUFUN_CLOSE
  417.  
  418. static EUFUN_0( Fn_load_path)
  419. {
  420.   return(SYSTEM_GLOBAL_VALUE(list_search_path));
  421. }
  422. EUFUN_CLOSE
  423.  
  424. static EUFUN_1( Fn_load_path_setter, val)
  425. {
  426.   return((SYSTEM_GLOBAL_VALUE(list_search_path) = val));
  427. }
  428. EUFUN_CLOSE
  429.  
  430. static EUFUN_3( Rf_em, m, e, f)
  431. {
  432.   return Rf_enter_module(stackbase);
  433. }
  434. EUFUN_CLOSE
  435.  
  436. static EUFUN_3( Rf_rem, m, e, f)
  437. {
  438.   EUCALL_3(Rf_reload_module,m,e,f);
  439.   return Rf_enter_module(stackbase);
  440. }
  441. EUFUN_CLOSE
  442.  
  443. void initialise_root(LispObject* stacktop)
  444. {
  445.   extern char *getenv(char *);
  446.   extern LispObject Fn_nconc(LispObject*);
  447.   char *path_list;
  448.  
  449.   SYSTEM_INITIALISE_GLOBAL(int,load_verbosity,0);
  450.   SYSTEM_INITIALISE_GLOBAL(LispObject,list_search_path,nil);
  451.  
  452.   ADD_SYSTEM_GLOBAL_ROOT(list_search_path);
  453.  
  454.   /* Initialise the paths... */
  455.   
  456.   path_list = getenv(LOAD_PATH_NAME);
  457.  
  458.   if (path_list == NULL) {
  459.     SYSTEM_GLOBAL_VALUE(list_search_path) 
  460.       = EUCALL_2(Fn_cons,
  461.          allocate_string(stacktop,MODULE_PATH,strlen(MODULE_PATH)),
  462.          SYSTEM_GLOBAL_VALUE(list_search_path));
  463.     SYSTEM_GLOBAL_VALUE(list_search_path) 
  464.       = EUCALL_2(Fn_cons, allocate_string(stacktop,".",1),
  465.          SYSTEM_GLOBAL_VALUE(list_search_path));
  466.   }
  467.   else {
  468.     char *next;
  469.  
  470.     next = strtok(path_list,":");
  471.     while (next != NULL) {
  472.       LispObject xx;
  473.       xx = allocate_string(stacktop,next,strlen(next));
  474.       EUCALLSET_2(xx, Fn_cons, xx,nil);
  475.       EUCALLSET_2(SYSTEM_GLOBAL_VALUE(list_search_path), 
  476.           Fn_nconc,SYSTEM_GLOBAL_VALUE(list_search_path), xx);
  477.       next = strtok(NULL,":");
  478.     }
  479.   }
  480.  
  481.   sym_eval_cm = get_symbol(stacktop,"eval/cm");    
  482.   add_root(&sym_eval_cm);
  483.   sym_set_cm = get_symbol(stacktop,"set/cm");
  484.   add_root(&sym_set_cm);
  485.   {
  486.     extern LispObject my_make_special(LispObject *,char *,LispObject (*)());
  487.  
  488.     (void) my_make_special(stacktop,"!>",Rf_em);
  489.     (void) my_make_special(stacktop,"!>>",Rf_rem);
  490.   }
  491.  
  492.   open_module(stacktop,&Module_root,Module_root_values,"root",ROOT_ENTRIES);
  493.  
  494.   (void) make_unexported_module_special(stacktop,"defmodule",Rf_defmodule);
  495.   (void) make_unexported_module_special(stacktop,"load-module",Rf_load_module);
  496.   (void) make_unexported_module_special(stacktop,
  497.                     "reload-module",Rf_reload_module);
  498.   (void) make_unexported_module_special(stacktop,
  499.                     "enter-module",Rf_enter_module);
  500.   (void) make_unexported_module_special(stacktop,
  501.                     "loaded-modules",Rf_loaded_modules);
  502.   (void) make_unexported_module_special(stacktop,
  503.                     "start-module",Rf_start_module);
  504.   (void) make_unexported_module_special(stacktop,"load-expanded-module",
  505.                     Rf_load_expanded_module);
  506.   (void) make_unexported_module_special(stacktop,
  507.                     "load-quietly",Rf_load_quietly);
  508.   (void) make_unexported_module_special(stacktop,"load-loudly",Rf_load_loudly);
  509.  
  510.   (void) make_unexported_module_function(stacktop,"load-path",Fn_load_path,0);
  511.   (void) make_unexported_module_function(stacktop,"set-load-path",
  512.                      Fn_load_path_setter,1);
  513.  
  514.   close_module();
  515. }
  516.